;; collection/squeue.scm - (c) rohan drape, 2000-2004

;; A scheduling queue.  This is a specialized form of a priority
;; queue.  The queue is maintained in ascending order.  Each element
;; is a cons cell, the car holds the numerical key of the entry, the
;; cdr the dispatch procedure associated with that key.  The last cons
;; cell of the data is stored at `rear' to allow optimization of
;; insertions at the rear of the queue.

;; The elide value is the interval at which adjacent entries will be
;; elided into one entry.  The elide is made to the time of the
;; existing entry, not to the time of the requested entry.  This value
;; should be set to the smallest perceptually significant interval for
;; whatever is being queued.  For musical work a value of 1ms
;; (1/1000th of a second) is usually workable.  This value is the
;; `quantization' of the queue.  The main use of this is not in
;; limiting the number of entries in the queue, which it does, but in
;; avoiding impossible and pointless timer requests.

(define-structure squeue (data rear elide))

(defineV (make-squeue)
  (make-squeue* '() '() 1/1000))

;; Place the no-argument procedure `procedure' into the queue at key
;; `time'.  Evaluates to '#t' if the entry is inserted at the front of
;; the queue, else '#f'.

(define (squeue-insert! q time procedure)

  ;; The queue is reset if the new entry is at the front of the queue.

  (let ((reset #f))

    ;; SPECIAL CASE: Queue is empty, make entry, set rear store,
    ;; queue reset.
    
    (if (null? (squeue-data q))
	(begin 
	  (set-squeue-data! q (cons (cons time procedure) '()))
	  (set-squeue-rear! q (squeue-data q))
	  (set! reset #t))

	;; SPECIAL CASE: This insertion is at the front of the queue
	;; and will not elide with the current front of the queue.
	;; Queue reset.  The elision case is handled below.

	(if (< time (- (car (car (squeue-data q))) (squeue-elide q)))
	    (begin
	      (set-squeue-data! q (cons (cons time procedure) (squeue-data q)))
	      (set! reset #t))
	    
	    ;; SPECIAL CASE: This insertion is at the rear of the
	    ;; queue, or will elide with the rear value.  Both cases
	    ;; are handled here.  Storing the last cons cell of the
	    ;; list allows for insertions at the end to be made very
	    ;; quickly, otherwise this would have to traverse the
	    ;; entire queue, and insertions at the end are a common
	    ;; occurence in many algorithms.  The overhead in
	    ;; supporting this is isolated to the special case here,
	    ;; and to the empty queue case handled above.

	    (if (> time (- (car (car (squeue-rear q))) (squeue-elide q)))
		(let ((entry (car (squeue-rear q))))
		  (if (> time (+ (car entry) (squeue-elide q)))
		      (begin 
			(set-cdr! (squeue-rear q) 
				  (cons (cons time procedure) '()))
			(set-squeue-rear! q (cdr (squeue-rear q))))
		      (let ((existing-procedure (cdr entry)))
			(set-cdr! entry (lambda z
					  (apply existing-procedure z) 
					  (apply procedure z))))))
		
		;; Otherwise loop through from start.  `prev' is the
		;; list starting at the entry before the entry currently
		;; under consideration.  This is mutated when an
		;; `ordinary' insertion is made.  `rest' is the list
		;; starting at the current entry.  At the first
		;; iteration `prev' is null, however the insertion is
		;; known not to be before the first element due to the
		;; special case above.

		(let loop ((prev '())
			   (rest (squeue-data q)))
		  
		  ;; ERROR CASE: This insertion is at the end of the
		  ;; queue.  This should have been handled by the
		  ;; special case above, so raise an error here.
		  ;; Users should never see this error.

		  (if (null? rest)
		      (error "Implementation error in squeue-insert!")

		      ;; We need to inspect the current entry.

		      (let ((entry (car rest)))
			
			;; SPECIAL CASE: This insertion is at the same time,
			;; given the current elide value, as an existing
			;; entry.  Set the current procedure slot to a new
			;; procedure that runs both procedures.

			(if (< (abs (- time (car entry))) (squeue-elide q))
			    (let ((existing-procedure (cdr entry)))
			      (set-cdr! entry (lambda z 
						(apply existing-procedure z) 
						(apply procedure z))))
			    
			    ;; `ORDINARY' CASE.  If this insertion is before
			    ;; the current entry, mutate the list structure,
			    ;; else recurse.  We know that prev is not the
			    ;; null.

			    (if (< time (car entry))
				(set-cdr! prev (cons (cons time procedure)
						     rest))
				(loop rest (cdr rest))))))))))
    reset))

;; Return #t iff there are no entries in the queue.

(define (squeue-empty? q)
  (null? (squeue-data q)))

;; Return the time of the first entry in the queue `q', or #f.

(define (squeue-peek q)
  (let ((data (squeue-data q)))
    (if (null? data) #f	(caar data))))

;; Return the first entry from the queue and delete that entry.  An
;; error is raised if the queue is empty.

(define (squeue-pop! q)
  (let ((data (squeue-data q)))
    (begin (set-squeue-data! q (cdr data))
	   (car data))))

;; Delete all items from the queue.

(define (squeue-clear! q)
  (set-squeue-data! q '()))

;; Applies the procedure of the first entry in the queue to the key of
;; that entry and any `args' and returns the key of the next entry in
;; the queue, or false if there are no further entries.

;; Implementation note: The procedure that is executed here may make
;; an insertion to the squeue `q'.  This is an ordinary use.  Thus the
;; cached data may not be valid and we must fetch the new data before
;; deciding if a dispatch is required.

(define (squeue-dispatch! q . args)
  (let ((data (squeue-data q)))
    (set-squeue-data! q (cdr data))
    (with-exception-handler 
     (lambda (err) (inform "squeue-dispatch!: error detected:" err))
     (lambda () (apply (cdar data) (caar data) args)))
    (let ((new-data (squeue-data q)))
      (if (null? new-data)
	  #f
	  (caar new-data)))))

;; A variant dispatch that ensures that the time at the head of the
;; queue `q' is greater than or equal to `n'.  If the dispatch does
;; not proceed evaluates to '#f'.  

(define (squeue-dispatch!* q n . args)
  (let ((next (squeue-peek q)))
    (if (and next (>= n next))
	(apply squeue-dispatch! q args)
	#f)))
